Hi,

soltle so funktionieren:

Option Explicit

Sub DatenÜbertragen()
Dim AV, LC&(1), R&, I%, TS$, FS$, TSum#
fLC LC, 5, 7, , , Sheets("Auswertung")
AV = Sheets("Auswertung").Range("E1:F" & LC(0)).Value

    For R = LBound(AV) To UBound(AV)
        If AV(R, 1) = "Kostenstellen" Then
            
            For I = 1 To 5
                If R + I > UBound(AV) Then Exit For
                TSum = TSum + AV(R + I, 2)
            Next
            
            For I = 1 To 5
                
                If R + I > UBound(AV) Then Exit For
                TS = AV(R + I, 2)
                If TS = "" Then Exit For
                TS = Application.WorksheetFunction.Round(TS / TSum * 100, 2)
                
                If TS <> "" Then
                    
                    If FS = "" Then
                        FS = AV(R + I, 1) & " [" & TS & " %]"
                    Else
                        FS = FS & ";" & AV(R + I, 1) & " [" & TS & " %]"
                    End If
                    
                End If
                
            Next
            
            If FS <> "" Then
                Sheets("MSP").Range("J" & R).Value = FS
                FS = ""
            End If
            
        End If
            
    Next

End Sub

Private Sub fLC( _
ByRef LC&(), _
Optional ByVal S2%, _
Optional ByVal E2%, _
Optional ByVal S1&, _
Optional ByVal E1&, _
Optional tSh As Worksheet, _
Optional WB As Workbook _
)
Dim C%, R&, TV&, TV2&
If E1 = 0 Then E1 = Rows.Count
If E2 = 0 Then E2 = Columns.Count
If S1 = 0 Then S1 = 1
If S2 = 0 Then S2 = 1
If tSh Is Nothing Then Set tSh = ActiveSheet
If Not WB Is Nothing Then WB.Activate
    
    With tSh
        TV2 = .Cells(S1, E2).End(xlToLeft).Column
        For C = S2 To E2
            
            TV = .Cells(E1, C).End(xlUp).Row
            If TV > LC(0) Then LC(0) = TV
            If TV <> 1 And C > TV2 Then LC(1) = C
            
        Next
        If LC(1) = 0 Then LC(1) = TV2
    End With
    
End Sub

Till